home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-window.el.z / vm-window.el
Encoding:
Text File  |  1998-05-21  |  23.1 KB  |  648 lines
  1. ;;; Window management code for VM
  2. ;;; Copyright (C) 1989-1997 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-window)
  19.  
  20. (defun vm-display (buffer display commands configs
  21.            &optional do-not-raise)
  22. ;; the clearinghouse VM display function.
  23. ;;
  24. ;; First arg BUFFER non-nil is a buffer to display or undisplay.
  25. ;; nil means there is no request to display or undisplay a
  26. ;; buffer.
  27. ;;
  28. ;; Second arg DISPLAY non-nil means to display the buffer, nil means
  29. ;; to undisplay it.  This function guarantees to display the
  30. ;; buffer if requested.  Undisplay is not guaranteed.
  31. ;;
  32. ;; Third arg COMMANDS is a list of symbols.  this-command must
  33. ;; match one of these symbols for a window configuration to be
  34. ;; applied.
  35. ;;
  36. ;; Fourth arg CONFIGS is a list of window configurations to try.
  37. ;; vm-set-window-configuration will step through the list looking
  38. ;; for an existing configuration, and apply the one it finds.
  39. ;;
  40. ;; Display is done this way:
  41. ;;  1. if the buffer is visible in an invisible frame, make that frame visible
  42. ;;  2. if the buffer is already displayed, quit
  43. ;;  3. if vm-display-buffer-hook in non-nil
  44. ;;        run the hooks
  45. ;;        use the selected window/frame to display the buffer
  46. ;;        quit
  47. ;;  4. apply a window configuration
  48. ;;        if the buffer is displayed now, quit
  49. ;;  5. call vm-display-buffer which will display the buffer.
  50. ;;
  51. ;; Undisplay is done this way:
  52. ;;  1. if the buffer is not displayed, quit
  53. ;;  2. if vm-undisplay-buffer-hook is non-nil
  54. ;;        run the hooks
  55. ;;        quit
  56. ;;  3. apply a window configuration
  57. ;;  4, if a window configuration was applied
  58. ;;        quit
  59. ;;  5. call vm-undisplay-buffer which will make the buffer
  60. ;;     disappear from at least one window/frame.
  61. ;;
  62. ;; If display/undisplay is not requested, only window
  63. ;; configuration is done, and only then if the value of
  64. ;; this-command is found in the COMMANDS list.
  65.   (vm-save-buffer-excursion
  66.    (let* ((w (and buffer (vm-get-buffer-window buffer)))
  67.       (wf (and w (vm-window-frame w))))
  68.      (and buffer (set-buffer buffer))
  69.      (if (and w display (not do-not-raise))
  70.      (vm-raise-frame wf))
  71.      (if (and w display (not (eq (vm-selected-frame) wf)))
  72.      (vm-select-frame wf))
  73.      (cond ((and buffer display)
  74.         (if (and vm-display-buffer-hook
  75.              (null (vm-get-visible-buffer-window buffer)))
  76.         (progn (run-hooks 'vm-display-buffer-hook)
  77.                (switch-to-buffer buffer))
  78.           (if (not (and (memq this-command commands)
  79.                 (apply 'vm-set-window-configuration configs)
  80.                 (vm-get-visible-buffer-window buffer)))
  81.           (vm-display-buffer buffer))))
  82.        ((and buffer (not display))
  83.         (if (and vm-undisplay-buffer-hook
  84.              (vm-get-visible-buffer-window buffer))
  85.         (progn (set-buffer buffer)
  86.                (run-hooks 'vm-undisplay-buffer-hook))
  87.           (if (not (and (memq this-command commands)
  88.                 (apply 'vm-set-window-configuration configs)))
  89.           (vm-undisplay-buffer buffer))))
  90.        ((memq this-command commands)
  91.         (apply 'vm-set-window-configuration configs))))))
  92.  
  93. (defun vm-display-buffer (buffer)
  94.   (let ((pop-up-windows (eq vm-mutable-windows t))
  95.     (pop-up-frames (and pop-up-frames vm-mutable-frames)))
  96.     (if (or pop-up-frames
  97.         (and (eq vm-mutable-windows t)
  98.          (symbolp
  99.           (vm-buffer-to-label
  100.            (window-buffer
  101.             (selected-window))))))
  102.     (select-window (display-buffer buffer))
  103.       (switch-to-buffer buffer))))
  104.  
  105. (defun vm-undisplay-buffer (buffer)
  106.   (vm-save-buffer-excursion
  107.    (let ((vm-mutable-frames (and vm-mutable-frames pop-up-frames)))
  108.      (vm-maybe-delete-windows-or-frames-on buffer))
  109.    (let (w)
  110.      (while (setq w (vm-get-buffer-window buffer))
  111.        (set-window-buffer w (other-buffer buffer))))))
  112.  
  113. (defun vm-load-window-configurations (file)
  114.   (save-excursion
  115.     (let ((work-buffer nil))
  116.       (unwind-protect
  117.       (progn
  118.         (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*")))
  119.         (erase-buffer)
  120.         (setq vm-window-configurations
  121.           (condition-case ()
  122.               (progn
  123.             (insert-file-contents file)
  124.             (read (current-buffer)))
  125.             (error nil))))
  126.     (and work-buffer (kill-buffer work-buffer))))))
  127.  
  128. (defun vm-store-window-configurations (file)
  129.   (save-excursion
  130.     (let ((work-buffer nil)
  131.       (coding-system-for-read 'no-conversion)
  132.       (coding-system-for-write 'no-conversion))
  133.       (unwind-protect
  134.       (progn
  135.         (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*")))
  136.         ;; for XEmacs/MULE
  137.         (and vm-xemacs-mule-p
  138.          (set-buffer-file-coding-system 'no-conversion))
  139.         (erase-buffer)
  140.         (print vm-window-configurations (current-buffer))
  141.         (write-region (point-min) (point-max) file nil 0))
  142.     (and work-buffer (kill-buffer work-buffer))))))
  143.  
  144. (defun vm-set-window-configuration (&rest tags)
  145.   (catch 'done
  146.     (if (not vm-mutable-windows)
  147.     (throw 'done nil))
  148.     (let ((nonexistent " *vm-nonexistent*")
  149.       (nonexistent-summary " *vm-nonexistent-summary*")
  150.       (selected-frame (vm-selected-frame))
  151.       summary message composition edit config)
  152.       (while (and tags (null config))
  153.     (setq config (assq (car tags) vm-window-configurations)
  154.           tags (cdr tags)))
  155.       (or config (setq config (assq 'default vm-window-configurations)))
  156.       (or config (throw 'done nil))
  157.       (setq config (vm-copy config))
  158.       (setq composition (vm-find-composition-buffer t))
  159.       (cond ((eq major-mode 'vm-summary-mode)
  160.          (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer)))
  161.          (throw 'done nil)
  162.            (setq summary (current-buffer))
  163.            (setq message vm-mail-buffer)))
  164.         ((eq major-mode 'vm-mode)
  165.          (setq message (current-buffer)))
  166.         ((eq major-mode 'vm-presentation-mode)
  167.          (setq message vm-mail-buffer))
  168.         ((eq major-mode 'vm-virtual-mode)
  169.          (setq message (current-buffer)))
  170.         ((eq major-mode 'mail-mode)
  171.          (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer)))
  172.          (throw 'done nil)
  173.            (setq message vm-mail-buffer
  174.              ;; assume that the proximity implies affinity
  175.              composition (current-buffer))))
  176.         ((eq vm-system-state 'editing)
  177.          (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer)))
  178.          (throw 'done nil)
  179.            (setq edit (current-buffer))
  180.            (setq message vm-mail-buffer)))
  181.         ;; not in a VM related buffer, bail...
  182.         (t (throw 'done nil)))
  183.       (set-buffer message)
  184.       (vm-check-for-killed-presentation)
  185.       (if vm-presentation-buffer
  186.       (setq message vm-presentation-buffer))
  187.       (vm-check-for-killed-summary)
  188.       (or summary (setq summary (or vm-summary-buffer nonexistent-summary)))
  189.       (or composition (setq composition nonexistent))
  190.       (or edit (setq edit nonexistent))
  191.       (tapestry-replace-tapestry-element (nth 1 config) 'buffer-name
  192.                      (function
  193.                       (lambda (x)
  194.                         (if (symbolp x)
  195.                         (symbol-value x)
  196.                           x ))))
  197.       (set-tapestry (nth 1 config) 1)
  198.       (and (get-buffer nonexistent)
  199.        (vm-maybe-delete-windows-or-frames-on nonexistent))
  200.       (if (and (vm-get-buffer-window nonexistent-summary)
  201.            (not (vm-get-buffer-window message)))
  202.       ;; user asked for summary to be displayed but doesn't
  203.       ;; have one, nor is the folder buffer displayed.  Help
  204.       ;; the user not to lose here.
  205.       (vm-replace-buffer-in-windows nonexistent-summary message)
  206.     (and (get-buffer nonexistent-summary)
  207.          (vm-maybe-delete-windows-or-frames-on nonexistent-summary)))
  208.       config )))
  209.  
  210. (defun vm-save-window-configuration (tag)
  211.   "Name and save the current window configuration.
  212. With this command you associate the current window setup with an
  213. action.  Each time you perform this action VM will duplicate this
  214. window setup.
  215.  
  216. Nearly every VM command can have a window configuration
  217. associated with it.  VM also allows some category configurations,
  218. `startup', `reading-message', `composing-message', `editing-message',
  219. `marking-message' and `searching-message' for the commands that
  220. do these things.  There is also a `default' configuration that VM
  221. will use if no other configuration is applicable.  Command
  222. specific configurations are searched for first, then the category
  223. configurations and then the default configuration.  The first
  224. configuration found is the one that is applied.
  225.  
  226. The value of vm-mutable-windows must be non-nil for VM to use
  227. window configurations."
  228.   (interactive
  229.    (let ((last-command last-command)
  230.      (this-command this-command))
  231.      (if (null vm-window-configuration-file)
  232.      (error "Configurable windows not enabled.  Set vm-window-configuration-file to enable."))
  233.      (list
  234.       (intern
  235.        (completing-read "Name this window configuration: "
  236.             vm-supported-window-configurations
  237.             'identity t)))))
  238.   (if (null vm-window-configuration-file)
  239.       (error "Configurable windows not enabled.  Set vm-window-configuration-file to enable."))
  240.   (let (map p)
  241.     (setq map (tapestry (list (vm-selected-frame))))
  242.     ;; set frame map to nil since we don't use it.  this prevents
  243.     ;; cursor objects and any other objects that have an
  244.     ;; "unreadable" read syntax appearing in the window
  245.     ;; configuration file by way of frame-parameters.
  246.     (setcar map nil)
  247.     (tapestry-replace-tapestry-element map 'buffer-name 'vm-buffer-to-label)
  248.     (tapestry-nullify-tapestry-elements map t nil t t t nil)
  249.     (setq p (assq tag vm-window-configurations))
  250.     (if p
  251.     (setcar (cdr p) map)
  252.       (setq vm-window-configurations
  253.         (cons (list tag map) vm-window-configurations)))
  254.     (vm-store-window-configurations vm-window-configuration-file)
  255.     (message "%s configuration recorded" tag)))
  256.  
  257. (defun vm-buffer-to-label (buf)
  258.   (save-excursion
  259.     (set-buffer buf)
  260.     (cond ((eq major-mode 'vm-summary-mode)
  261.        'summary)
  262.       ((eq major-mode 'mail-mode)
  263.        'composition)
  264.       ((eq major-mode 'vm-mode)
  265.        'message)
  266.       ((eq major-mode 'vm-virtual-mode)
  267.        'message)
  268.       ((eq vm-system-state 'editing)
  269.        'edit)
  270.       (t buf))))
  271.  
  272. (defun vm-delete-window-configuration (tag)
  273.   "Delete the configuration saved for a particular action.
  274. This action will no longer have an associated window configuration.
  275. The action will be read from the minibuffer."
  276.   (interactive
  277.    (let ((last-command last-command)
  278.      (this-command this-command))
  279.      (if (null vm-window-configuration-file)
  280.      (error "Configurable windows not enabled.  Set vm-window-configuration-file to enable."))
  281.      (list
  282.       (intern
  283.        (completing-read "Delete window configuration: "
  284.             (mapcar (function
  285.                  (lambda (x)
  286.                    (list (symbol-name (car x)))))
  287.                 vm-window-configurations)
  288.             'identity t)))))
  289.   (if (null vm-window-configuration-file)
  290.       (error "Configurable windows not enabled.  Set vm-window-configuration-file to enable."))
  291.   (let (p)
  292.     (setq p (assq tag vm-window-configurations))
  293.     (if p
  294.     (if (eq p (car vm-window-configurations))
  295.         (setq vm-window-configurations (cdr vm-window-configurations))
  296.       (setq vm-window-configurations (delq p vm-window-configurations)))
  297.       (error "No window configuration set for %s" tag)))
  298.   (vm-store-window-configurations vm-window-configuration-file)
  299.   (message "%s configuration deleted" tag))
  300.  
  301. (defun vm-apply-window-configuration (tag)
  302.   "Change the current window configuration to be one
  303. associated with a particular action.  The action will be read
  304. from the minibuffer."
  305.   (interactive
  306.    (let ((last-command last-command)
  307.      (this-command this-command))
  308.      (list
  309.       (intern
  310.        (completing-read "Apply window configuration: "
  311.             (mapcar (function
  312.                  (lambda (x)
  313.                    (list (symbol-name (car x)))))
  314.                 vm-window-configurations)
  315.             'identity t)))))
  316.   (vm-set-window-configuration tag))
  317.  
  318. (defun vm-window-help ()
  319.   (interactive)
  320.   (message "WS = save configuration, WD = delete configuration, WW = apply configuration"))
  321.  
  322. (defun vm-iconify-frame ()
  323.   "Iconify the current frame.
  324. Run the hooks in vm-iconify-frame-hook before doing so."
  325.   (interactive)
  326.   (vm-check-for-killed-summary)
  327.   (vm-select-folder-buffer)
  328.   (if (vm-multiple-frames-possible-p)
  329.       (progn
  330.     (run-hooks 'vm-iconify-frame-hook)
  331.     (vm-iconify-frame-xxx))))
  332.  
  333. (defun vm-window-loop (action obj-1 &optional obj-2)
  334.   (let ((delete-me nil)
  335.     (done nil)
  336.     (all-frames (if vm-search-other-frames t nil))
  337.     start w)
  338.     (setq start (next-window (selected-window) 'nomini all-frames)
  339.       w start)
  340.     (and obj-1 (setq obj-1 (get-buffer obj-1)))
  341.     (while (not done)
  342.       (if (and delete-me (not (eq delete-me (next-window delete-me 'nomini))))
  343.       (progn
  344.         (delete-window delete-me)
  345.         (if (eq delete-me start)
  346.         (setq start nil))
  347.         (setq delete-me nil)))
  348.       (cond ((and (eq action 'delete) (eq obj-1 (window-buffer w)))
  349.          ;; a deleted window has no next window, so we
  350.          ;; defer the deletion until after we've moved
  351.          ;; to the next window.
  352.          (setq delete-me w))
  353.         ((and (eq action 'replace) (eq obj-1 (window-buffer w)))
  354.          (set-window-buffer w obj-2)))
  355.       (setq done (eq start
  356.              (setq w
  357.               (condition-case nil
  358.                   (next-window w 'nomini all-frames)
  359.                 (wrong-number-of-arguments
  360.                  (next-window w 'nomini))))))
  361.       (if (null start)
  362.       (setq start w)))
  363.     (if (and delete-me (not (eq delete-me (next-window delete-me 'nomini))))
  364.     (delete-window delete-me))))
  365.  
  366. (defun vm-frame-loop (action obj-1)
  367.   (if (fboundp 'vm-next-frame)
  368.       (let ((start (vm-next-frame (vm-selected-frame)))
  369.         (delete-me nil)
  370.         (done nil)
  371.         f)
  372.     (setq f start)
  373.     (and obj-1 (setq obj-1 (get-buffer obj-1)))
  374.     (while (not done)
  375.       (if delete-me
  376.           (progn
  377.         (condition-case nil
  378.             (progn
  379.               (if (vm-created-this-frame-p delete-me)
  380.               (vm-delete-frame delete-me))
  381.               (if (eq delete-me start)
  382.               (setq start nil)))
  383.           (error nil))
  384.         (setq delete-me nil)))
  385.       (cond ((and (eq action 'delete)
  386.               ;; one-window-p doesn't take a frame argument
  387.               (eq (next-window (vm-frame-selected-window f) 'nomini)
  388.               (previous-window (vm-frame-selected-window f)
  389.                        'nomini))
  390.               ;; the next-window call is to avoid looking
  391.               ;; at the minibuffer window
  392.               (eq obj-1 (window-buffer
  393.                  (next-window
  394.                   (vm-frame-selected-window f)
  395.                   'nomini))))
  396.          ;; a deleted frame has no next frame, so we
  397.          ;; defer the deletion until after we've moved
  398.          ;; to the next frame.
  399.          (setq delete-me f))
  400.         ((eq action 'bury)
  401.          (bury-buffer obj-1)))
  402.       (setq done (eq start (setq f (vm-next-frame f))))
  403.       (if (null start)
  404.           (setq start f)))
  405.     (if delete-me
  406.         (progn
  407.           (vm-error-free-call 'vm-delete-frame delete-me)
  408.           (setq delete-me nil))))))
  409.  
  410. (defun vm-maybe-delete-windows-or-frames-on (buffer)
  411.   (and (eq vm-mutable-windows t) (vm-window-loop 'delete buffer))
  412.   (and vm-mutable-frames (vm-frame-loop 'delete buffer)))
  413.  
  414. (defun vm-replace-buffer-in-windows (old new)
  415.   (vm-window-loop 'replace old new))
  416.  
  417. (defun vm-bury-buffer (&optional buffer)
  418.   (or buffer (setq buffer (current-buffer)))
  419.   (if vm-xemacs-p
  420.       (if (vm-multiple-frames-possible-p)
  421.       (vm-frame-loop 'bury buffer)
  422.     (bury-buffer buffer))
  423.     (bury-buffer buffer)))
  424.  
  425. (defun vm-unbury-buffer (buffer)
  426.   (save-excursion
  427.     (save-window-excursion
  428.       (switch-to-buffer buffer))))
  429.  
  430. (defun vm-get-buffer-window (buffer)
  431.   (condition-case nil
  432.       (or (get-buffer-window buffer nil nil)
  433.       (and vm-search-other-frames
  434.            (get-buffer-window buffer t t)))
  435.     (wrong-number-of-arguments
  436.      (condition-case nil
  437.      (or (get-buffer-window buffer nil)
  438.          (and vm-search-other-frames
  439.           (get-buffer-window buffer t)))
  440.        (wrong-number-of-arguments
  441.     (get-buffer-window buffer))))))
  442.  
  443. (defun vm-get-visible-buffer-window (buffer)
  444.   (condition-case nil
  445.       (or (get-buffer-window buffer nil nil)
  446.       (and vm-search-other-frames
  447.            (get-buffer-window buffer t nil)))
  448.     (wrong-number-of-arguments
  449.      (condition-case nil
  450.      (or (get-buffer-window buffer nil)
  451.          (and vm-search-other-frames
  452.           (get-buffer-window buffer 'visible)))
  453.        (wrong-number-of-arguments
  454.     (get-buffer-window buffer))))))
  455.  
  456. (defun vm-set-hooks-for-frame-deletion ()
  457.   (make-local-variable 'vm-undisplay-buffer-hook)
  458.   (add-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame)
  459.   (add-hook 'kill-buffer-hook 'vm-delete-buffer-frame))
  460.  
  461. (defun vm-created-this-frame-p (&optional frame)
  462.   (memq (or frame (vm-selected-frame)) vm-frame-list))
  463.  
  464. (defun vm-delete-buffer-frame ()
  465.   ;; kludge.  we only want to this to run on VM related buffers
  466.   ;; but this function is generally on a global hook.  Check for
  467.   ;; vm-undisplay-buffer-hook set; this is a good sign that this
  468.   ;; is a VM buffer.
  469.   (if vm-undisplay-buffer-hook
  470.       (save-excursion
  471.     ;; run once only per buffer.
  472.     (remove-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame)
  473.     (let* ((w (vm-get-visible-buffer-window (current-buffer)))
  474.            (b (current-buffer))
  475.            (wf (and w (vm-window-frame w))))
  476.       (and w (eq (vm-selected-frame) wf) (vm-created-this-frame-p wf)
  477.            (vm-error-free-call 'vm-delete-frame wf))
  478.       (and w (let ((vm-mutable-frames t))
  479.            (vm-maybe-delete-windows-or-frames-on b)))))))
  480.  
  481. (defun vm-register-frame (frame)
  482.   (setq vm-frame-list (cons frame vm-frame-list)))
  483.  
  484. (defun vm-goto-new-frame (&rest types)
  485.   (let ((params nil))
  486.     (while (and types (null params))
  487.       (setq params (car (cdr (assq (car types) vm-frame-parameter-alist)))
  488.         types (cdr types)))
  489.     ;; these functions might be defined in an Emacs that isn't
  490.     ;; running under a window system, but VM always checks for
  491.     ;; multi-frame support before calling this function.
  492.     (cond ((fboundp 'make-frame)
  493.        (select-frame (make-frame params)))
  494.       ((fboundp 'make-screen)
  495.        (select-screen (make-screen params)))
  496.       ((fboundp 'new-screen)
  497.        (select-screen (new-screen params))))
  498.     (vm-register-frame (vm-selected-frame))
  499.     (and vm-warp-mouse-to-new-frame
  500.      (vm-warp-mouse-to-frame-maybe (vm-selected-frame)))))
  501.  
  502. (defun vm-goto-new-summary-frame-maybe ()
  503.   (if (and vm-mutable-frames vm-frame-per-summary
  504.        (vm-multiple-frames-possible-p))
  505.       (let ((w (vm-get-buffer-window vm-summary-buffer)))
  506.     (if (null w)
  507.         (progn
  508.           (vm-goto-new-frame 'summary)
  509.           (vm-set-hooks-for-frame-deletion))
  510.       (save-excursion
  511.         (select-window w)
  512.         (and vm-warp-mouse-to-new-frame
  513.          (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))))
  514.  
  515. (defun vm-goto-new-folder-frame-maybe (&rest types)
  516.   (if (and vm-mutable-frames vm-frame-per-folder
  517.        (vm-multiple-frames-possible-p))
  518.       (let ((w (or (vm-get-buffer-window (current-buffer))
  519.            ;; summary == folder for the purpose
  520.            ;; of frame reuse.
  521.            (and vm-summary-buffer
  522.             (vm-get-buffer-window vm-summary-buffer))
  523.            ;; presentation == folder for the purpose
  524.            ;; of frame reuse.
  525.            (and vm-presentation-buffer
  526.             (vm-get-buffer-window vm-presentation-buffer)))))
  527.     (if (null w)
  528.         (progn
  529.           (apply 'vm-goto-new-frame types)
  530.           (vm-set-hooks-for-frame-deletion))
  531.       (save-excursion
  532.         (select-window w)
  533.         (and vm-warp-mouse-to-new-frame
  534.          (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))))
  535.  
  536. (defun vm-warp-mouse-to-frame-maybe (&optional frame)
  537.   (or frame (setq frame (vm-selected-frame)))
  538.   (if (vm-mouse-support-possible-here-p)
  539.       (cond ((vm-mouse-xemacs-mouse-p)
  540.          (cond ((fboundp 'mouse-position);; XEmacs 19.12
  541.             (let ((mp (mouse-position)))
  542.               (if (and (car mp)
  543.                    (eq (window-frame (car mp)) (selected-frame)))
  544.               nil
  545.             (set-mouse-position (frame-highest-window frame)
  546.                         (/ (frame-width frame) 2)
  547.                         (/ (frame-height frame) 2)))))
  548.            (t ;; XEmacs 19.11
  549.             ;; use (apply 'screen-...) instead of
  550.             ;; (screen-...) to avoid stimulating a
  551.             ;; byte-compiler bug in Emacs 19.29 that
  552.             ;; happens when it encounters 'obsolete'
  553.             ;; functions.  puke, puke, puke.
  554.             (let ((mp (read-mouse-position frame)))
  555.               (if (and (>= (car mp) 0)
  556.                    (<= (car mp) (apply 'screen-width frame))
  557.                    (>= (cdr mp) 0)
  558.                    (<= (cdr mp) (apply 'screen-height frame)))
  559.               nil
  560.             (set-mouse-position frame
  561.                         (/ (apply 'screen-width frame) 2)
  562.                         (/ (apply 'screen-height frame) 2)))))))
  563.         ((vm-fsfemacs-p)
  564.          (let ((mp (mouse-position)))
  565.            (if (and (eq (car mp) frame)
  566.             ;; nil coordinates mean that the mouse
  567.             ;; pointer isn't really within the frame
  568.             (car (cdr mp)))
  569.            nil
  570.          (set-mouse-position frame
  571.                      (/ (frame-width frame) 2)
  572.                      (/ (frame-height frame) 2))
  573.          ;; doc for set-mouse-position says to do this
  574.          (unfocus-frame)))))))
  575.  
  576. (fset 'vm-selected-frame
  577.       (symbol-function
  578.        (cond ((fboundp 'selected-frame) 'selected-frame)
  579.          ((fboundp 'selected-screen) 'selected-screen)
  580.          (t 'ignore))))
  581.  
  582. (fset 'vm-delete-frame
  583.       (symbol-function
  584.        (cond ((fboundp 'delete-frame) 'delete-frame)
  585.          ((fboundp 'delete-screen) 'delete-screen)
  586.          (t 'ignore))))
  587.  
  588. ;; xxx because vm-iconify-frame is a command
  589. (defun vm-iconify-frame-xxx (&optional frame)
  590.   (cond ((fboundp 'iconify-frame)
  591.      (iconify-frame frame))
  592.     ((fboundp 'iconify-screen)
  593.      (iconify-screen (or frame (selected-screen))))))
  594.  
  595. (fset 'vm-raise-frame
  596.       (symbol-function
  597.        (cond ((fboundp 'raise-frame) 'raise-frame)
  598.          ((fboundp 'raise-screen) 'raise-screen)
  599.          (t 'ignore))))
  600.  
  601. (fset 'vm-frame-visible-p
  602.       (symbol-function
  603.        (cond ((fboundp 'frame-visible-p) 'frame-visible-p)
  604.          ((fboundp 'screen-visible-p) 'screen-visible-p)
  605.          (t 'ignore))))
  606.  
  607. (if (fboundp 'frame-iconified-p)
  608.     (fset 'vm-frame-iconified-p 'frame-iconified-p)
  609.   (defun vm-frame-iconified-p (&optional frame)
  610.     (eq (vm-frame-visible-p frame) 'icon)))
  611.  
  612. ;; frame-totally-visible-p is broken under XEmacs 19.14 and is
  613. ;; absent under Emacs 19.34.  So vm-frame-per-summary won't work
  614. ;; quite right under these Emacs versions.  XEmacs 19.15 should
  615. ;; have a working version of this function.
  616. ;; 2 April 1997, frame-totally-visible-p apparently still broken
  617. ;; under 19.15.  I give up for now.
  618. ;;(if (and (fboundp 'frame-totally-visible-p)
  619. ;;     vm-xemacs-p
  620. ;;     (or (>= emacs-major-version 20)
  621. ;;         (>= emacs-minor-version 15)))
  622. ;;    (fset 'vm-frame-totally-visible-p 'frame-totally-visible-p)
  623. ;;  (fset 'vm-frame-totally-visible-p 'vm-frame-visible-p))
  624. (fset 'vm-frame-totally-visible-p 'vm-frame-visible-p)
  625.  
  626. (fset 'vm-window-frame
  627.       (symbol-function
  628.        (cond ((fboundp 'window-frame) 'window-frame)
  629.          ((fboundp 'window-screen) 'window-screen)
  630.          (t 'ignore))))
  631.  
  632. (cond ((fboundp 'next-frame)
  633.        (fset 'vm-next-frame (symbol-function 'next-frame))
  634.        (fset 'vm-select-frame (symbol-function 'select-frame))
  635.        (fset 'vm-frame-selected-window
  636.          (symbol-function 'frame-selected-window)))
  637.       ((fboundp 'next-screen)
  638.        (fset 'vm-next-frame (symbol-function 'next-screen))
  639.        (fset 'vm-select-frame (symbol-function 'select-screen))
  640.        (fset 'vm-frame-selected-window
  641.          (if (fboundp 'epoch::selected-window)
  642.          (symbol-function 'epoch::selected-window)
  643.            (symbol-function 'screen-selected-window))))
  644.       (t
  645.        ;; it is useful for this to be a no-op, but don't bind the
  646.        ;; others.
  647.        (fset 'vm-select-frame 'ignore)))
  648.